COMMENT ⊗   VALID 00005 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	(defvar *qletp* t)
C00003 00003	 This is a safe conser
C00006 00004	 Parallel Quicksort
C00008 00005	 Serial Version for comparison
C00011 ENDMK
C⊗;
(defvar *qletp* t)

(defun fib (n)
 (labels ((fib (n)
           (if (< n 2)
	       1
	       (qlet *qletp* ((n-1 (fib (- n 1)))
			      (n-2 (fib (- n 2))))
		     (+ n-1 n-2)))))
  (fib n)))

;;; (time (fib 25))
;;; (setq *qletp* nil)
;;; (time (fib 25))

;;; This is a safe conser
;;;
(defmacro lock-cons (x y)
 `(prog2 (get-lock *cons-lock*)
	 (cons ,x ,y)
	 (release-lock *cons-lock*)))

;;; Takes a list of atoms and builds a list structure that
;;; is approximately m cells wide everywhere and n deep total.
;;;
(defun init (m n atoms)
       (let ((atoms (subst () () atoms)))
        (labels ((init1 (m n)
		  (cond ((= m 0) (pop atoms))
			(t (do ((i n (- i 2))
				(a ()))
			       ((< i 1) a)
			       (push (pop atoms) a)
			       (push (init1 (1- m) n) a))))))
        (do ((a atoms (cdr a)))
	    ((null (cdr a)) (setf (cdr a) atoms)))
	(init1 m n))))

;;; Makes a binary tree of depth DEPTH with
;;; the atoms ONE and OTHER alternating
;;;
(defun bin-init (depth one other)
 (labels ((b-i (depth)
           (cond ((zerop depth) 
		  (rotatef one other)
		  other)
		 (t 
		  (cons (b-i (1- depth))
			(b-i (1- depth)))))))
   (b-i depth)))

;;; Vanilla SUBST but using LOCK-CONS
;;;
(defun sbst (x y z)
 (cond ((eq y z) x)
       ((atom z) z)
       (t
	(qlet nil ((q (sbst x y (car z)))
		   (r (sbst x y (cdr z))))
	      (lock-cons q r)))))

;;; Fully parallel SUBST
;;;
(defun qsubst (x y z)
 (cond ((eq y z) x)
       ((atom z) z)
       (t
	(qlet t ((q (qsubst x y (car z)))
		 (r (qsubst x y (cdr z))))
	      (lock-cons q r)))))

;;; Does a parallel subst at the top
;;; nodes only
;;;
(defun qsubst2 (x y z)
 (cond ((eq y z) x)
       ((atom z) z)
       (t
	(qlet t ((q (sbst x y (car z)))
		 (r (sbst x y (cdr z))))
	      (lock-cons q r)))))

;;; (change-memory-management :growth-limit 1000 :expand 200)
;;; (progn (setq *a* (bin-init 15 'a 'b)) t)
;;; (time (progn (sbst 'x 'a *a*) t))
;;; (time (progn (qsubst 'a 'x *a*) t))
;;; (time (progn (qsubst2 'x 'a *a*) t))
;;; Parallel Quicksort
;;;
(defun quicksort (a)
  (quicksort-aux a 0 (1- (length a)) 0))

(defun quicksort-aux (a m n depth)
 (cond ((not (< m n)))
       (t (let ((d (aref a m)))
           (let ((i (partition a m n d)))
            (setf (aref a i) d)
            (qlet (< depth 4) ((q (quicksort-aux a m (1- i) (1+ depth)))
			       (r (quicksort-aux a (1+ i) n (1+ depth))))
	     (declare (ignore q r))
	     t))))))

(defun partition (a m n d)
 (let ((i m) (j n))
  (tagbody
   down
   (let ((k (do ((q j (1- q)))
		((= i q) (return-from partition q))
              (when (< (aref a q) d) (return q)))))
    (setf (aref a i) (aref a k))
    (incf i)
    (setq j k))
   up
   (let ((k (do ((q i (1+ q)))
		((= j q) (return-from partition q))
              (when (> (aref a q) d) (return q)))))
    (setf (aref a j) (aref a k))
    (decf j)
    (setq i k)
    (go down)))))

(defvar *a*)

(defun init-array (n)
 (setq *a* (make-array (list n)))
 (dotimes (i n) (setf (aref *a* i) (random 200))))

(defun init-only-array (a)
 (dotimes (i (length a)) (setf (aref a i) (random 200))))
;;; Serial Version for comparison
;;;
(defun serial-quicksort (a)
  (serial-quicksort-aux a 0 (1- (length a)) 0))

(defun serial-quicksort-aux (a m n depth)
 (cond ((not (< m n)))
       (t (let ((d (aref a m)))
           (let ((i (partition a m n d)))
            (setf (aref a i) d)
            (serial-quicksort-aux a m (1- i) (1+ depth))
	    (serial-quicksort-aux a (1+ i) n (1+ depth))
	    t)))))